home *** CD-ROM | disk | FTP | other *** search
/ Gekikoh Dennoh Club 5 / Gekikoh Dennoh Club Vol. 5 (Japan).7z / Gekikoh Dennoh Club Vol. 5 (Japan) (Track 01).bin / docs / rakup / unify.vl < prev   
Lisp/Scheme  |  1998-10-03  |  3KB  |  130 lines
  1. ;
  2. ; UNIFY.VL : âXâyâVâââïò╧Éöé≡Ägé┴é╜âåâjâtâBâPü[âVâçâô
  3. ;
  4. ;            Copyright (C) 1998 by Makoto Hiroi
  5. ;
  6.  
  7. ;
  8. ; âåâjâtâBâPü[âVâçâô
  9. ;
  10. (defun unify (pattern datum binding)
  11.   (cond ((variablep pattern)
  12.          (unify-variable pattern datum binding))
  13.         ((variablep datum)
  14.      (unify-variable datum pattern binding))
  15.         ((and (atom pattern) (atom datum))
  16.          (unify-atoms pattern datum binding))
  17.         ((and (consp pattern) (consp datum))
  18.          (unify-pieces pattern datum binding))
  19.         (t (clear-binding binding))))
  20.  
  21. ;
  22. ; âAâgâÇé╞é╠âåâjâtâBâPü[âVâçâô
  23. ;
  24. (defun unify-atoms (pattern datum binding)
  25.   (if (equal pattern datum)
  26.       binding
  27.       (clear-binding binding)))
  28.  
  29. ;
  30. ; âèâXâgé╠âåâjâtâBâPü[âVâçâô
  31. ;
  32. (defun unify-pieces (pattern datum binding)
  33.   (let ((result (unify (car pattern) (car datum) binding)))
  34.     (if (eq result 'fail)
  35.         'fail
  36.         (unify (cdr pattern) (cdr datum) result))))
  37.  
  38. ;
  39. ; ò╧Éöé╞é╠âåâjâtâBâPü[âVâçâô
  40. ;
  41. (defun unify-variable (var datum binding)
  42.   (if (and (boundp var)
  43.            (not (eq (symbol-value var) var)))       ; Ä⌐ò¬Ä⌐Égé┼é═é╚éó
  44.       (unify (symbol-value var) datum binding)
  45.       (if (insidep var datum binding)
  46.           (clear-binding binding)
  47.           (add-binding var datum binding))))
  48.  
  49. ;
  50. ; datum é╠Æåé╔ var(ò╧Éö)é¬éáéΘé⌐
  51. ;
  52. (defun insidep (var datum binding)
  53.   (if (eq var datum)
  54.       nil
  55.       (inside-sub-p var datum binding)))
  56.  
  57.  
  58. (defun inside-sub-p (var datum binding)
  59.   (cond ((equal var datum) t)
  60.         ((atom datum) nil)
  61.         ((variablep datum)
  62.          (if (and (boundp datum)
  63.                   (not (eq (symbol-value datum) datum)))
  64.              (inside-sub-p var (symbol-value datum) binding)))
  65.         (t ; list é╠ÅΩìç
  66.          (or (inside-sub-p var (car datum) binding)
  67.              (inside-sub-p var (cdr datum) binding)))))
  68.                     
  69.  
  70. ;
  71. ; ò╧Éöæ⌐ö¢âèâXâgé⌐éτë≡ôÜé≡ò\Īé╖éΘ
  72. ;
  73. (defun print-answer (var-list)
  74.   (dolist (var var-list)
  75.     (format t "~A -> ~A\n" var (variable-value var))))
  76.  
  77. ;
  78. ; ò╧Éöé≡Æuè╖é╖éΘ
  79. ;
  80. (defun replace-variable (pattern)
  81.   (cond
  82.     ((variablep pattern)
  83.      (variable-value pattern))
  84.     ((atom pattern) pattern)
  85.     (t
  86.      (cons (replace-variable (car pattern))
  87.            (replace-variable (cdr pattern))))))
  88.  
  89. ;
  90. ; ò╧ÉöÆlé≡ïüé▀éΘ
  91. ;
  92. (defun variable-value (var)
  93.   (let (value)
  94.     (loop
  95.       (unless (boundp var) (return var)) ; ûóæ⌐ö¢
  96.       (setq value (symbol-value var))    ; âXâyâVâââïò╧Éöé≡ĵéΦÅoé╖
  97.       (cond
  98.         ((eq var value)    
  99.          (return value))                 ; Ä⌐ò¬Ä⌐Égé¬ôⁿé┴é─éóéΘ
  100.         ((variablep value)
  101.          (setq var value))
  102.         ((consp value)                   ; Æåé╔ò╧Éöé¬éáéΘé⌐éαé╡éΩé╚éóé╠é┼Æuè╖é╖éΘ
  103.      (return (replace-variable value)))
  104.         (t (return value))))))
  105.  
  106.  
  107. ;
  108. ; ò╧ÉöÆlé≡âZâbâgé╖éΘ
  109. ;
  110. (defun add-binding (var datum binding)
  111.   (set var datum)
  112.   (cons var binding))
  113.  
  114. ;
  115. ; ò╧Éöé≡âNâèâAé╡é─ 'fail é≡ò╘é╖
  116. ;
  117. (defun clear-binding (binding)
  118.   (if (consp binding)
  119.     (map nil #'makunbound binding))
  120.   'fail)
  121.  
  122. ;
  123. ; ùvæfé═ò╧Éöé⌐
  124. ;
  125. (defun variablep (pattern)
  126.   (and (symbolp pattern)
  127.        (upper-case-p (char pattern 0))))
  128.  
  129. ; end of file
  130.